home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus Special 15 / AMIGAplus Sonderheft 15 (1998)(ICP)(DE)[!].iso / rexx / whirlpool.pprx < prev    next >
Text File  |  1997-05-06  |  14KB  |  510 lines
  1. /* Personal Paint Amiga Rexx script - Copyright © 1996, 1997 Cloanto Italia srl */
  2.  
  3. /* $VER: Whirlpool.pprx 1.2 */
  4.  
  5. /** ENG
  6.  This script creates a text "whirlpool": a text string is rendered
  7.  along an elliptical path, using a vector font in the current foreground
  8.  color.
  9.  
  10.  This is a "tool macro": the mouse can be used to define an ellipse.
  11.  When the mouse button is released, a settings requester is
  12.  displayed. The settings include: font, text string, text size, start angle,
  13.  antialiasing, etc.
  14.  
  15.  If a single point (pixel), rather than an area, is selected, a requester
  16.  with the previously-used area coordinates is displayed: the parameters can
  17.  be modified to fine-tune the appearance of the "whirlpool".
  18.  
  19.  The text string specified in the settings requester may contain color
  20.  control sequences, in the format "Esc[3#m" or "[#]", where # is a pen
  21.  number (0 .. 256). The default (initial) color is the current foreground
  22.  color.
  23. */
  24.  
  25. /** DEU
  26.  Mit diesem Skript läßt sich ein Text-"Whirlpool" erzeugen. Dazu wird
  27.  eine Textzeichenkette dem Verlauf eines elliptischen Pfades angepaßt,
  28.  wobei ein Vektorfont in der aktuellen Vordergrundfarbe verwendet wird.
  29.  
  30.  Dies ist ein sog. "Tool-Makro": Zunächst wird mit Hilfe der Maus
  31.  die Ellipse erstellt. Sobald die Maustaste losgelassen wird, öffnet
  32.  sich ein Dialogfenster zur Festlegung von Einstellungen für Font,
  33.  Textstring, Zeichengröße, Startwinkel, Kantenglättung, usw.
  34.  
  35.  Wird anstelle eines Bereichs lediglich ein einzelner Punkt selektiert,
  36.  so öffnet sich ein Dialogfenster mit den zuletzt verwendeten
  37.  Bereichskoordinaten, welche sich dann zur Feinabstimmung des
  38.  Erscheinungsbildes den Anforderungen entsprechend modifizieren lassen.
  39.  
  40.  Hinweis: Der im Dialogfenster "Einstellungen" festgelegte Textstring kann
  41.  auch mit Steuerzeichen zur Aktivierung einer bestimmten Farbe versehen
  42.  werden. Diese müssen im Format "Esc[3#m]" oder "[#]" vorliegen, wobei das
  43.  Rautenzeichen # die Stiftnummer (0...256) angibt. Standardmäßig ist die
  44.  aktuelle Vordergrundfarbe eingestellt.
  45. */
  46.  
  47. /** ITA
  48.  Questo script crea un testo a "vortice": una stringa di testo è tracciata
  49.  lungo un percorso ellittico, usando un font vettoriale col colore di primo
  50.  piano corrente.
  51.  
  52.  È una "macro per strumenti": si può usare il mouse per definire una ellisse;
  53.  quando si rilascia il tasto del mouse, compare una finestra di dialogo per
  54.  l'impostazione dei parametri. I parametri comprendono: font, stringa di
  55.  testo, dimensioni del testo, smorzamento seghettature (antialiasing), ecc.
  56.  
  57.  Se si seleziona un punto singolo (pixel) anziché un'area, compare una finestra
  58.  di dialogo che mostra le coordinate dell'area precedente: tali parametri
  59.  possono essere modificati per raffinare l'aspetto del "vortice".
  60.  
  61.  La stringa di testo specificata nella finestra di dialogo delle impostazioni
  62.  può contenere sequenze di controllo per colori, nel formato "Esc[3#m" o "[#]",
  63.  dove # è il numero di un colore (0 .. 256). Il colore predefinito (iniziale)
  64.  è quello corrente di primo piano.
  65. */
  66.  
  67. IF ARG(1, EXISTS) THEN
  68.     PARSE ARG PPPORT button x0 y0 .
  69. ELSE
  70.     EXIT 0  /* macro execution only */
  71.  
  72. ADDRESS VALUE PPPORT
  73. OPTIONS RESULTS
  74. OPTIONS FAILAT 10000
  75.  
  76. Get 'LANG'
  77. IF RESULT = 1 THEN DO        /* Deutsch */
  78.     txt_title_zone    = "Whirlpool-Bereich"
  79.     txt_gad_x0        = "Zentrum _X:"
  80.     txt_gad_y0        = "Zentrum _Y:"
  81.     txt_gad_radiusx   = "_Radius X:"
  82.     txt_gad_radiusy   = "Radiu_s Y:"
  83.     txt_title_set     = "Whirlpool-Einstellungen"
  84.     txt_gad_font      = "_Font:"
  85.     txt_gad_text      = "_Text:"
  86.     txt_string_text   = "Dies ist Text für den Whirlpool-Effekt."
  87.     txt_gad_sheight   = "_Höhe Anfang:"
  88.     txt_gad_eheight   = "Höhe _Ende:"
  89.     txt_gad_fall      = "_Gefälle %:"
  90.     txt_gad_sangle    = "Winkel A_nfang:"
  91.     txt_gad_aalias    = "_Kantenglättung:"
  92.     txt_gad_aalias0   = "Keine"
  93.     txt_gad_aalias1   = "Schwach"
  94.     txt_gad_aalias2   = "Mittel"
  95.     txt_gad_aalias3   = "Stark"
  96.     txt_err_nofonts   = "Vektorfonts nicht auffindbar"
  97.     txt_err_procss    = "Fehler bei Bildbearbeitung: "
  98.     txt_err_small     = "Ausgewählter Bereich ist zu klein"
  99.     txt_err_nomem     = "Zu wenig Speicher"
  100.     txt_err_oldclient = "Für dieses Skript_ist eine neuere Version_von Personal Paint erforderlich"
  101. END
  102. ELSE IF RESULT = 2 THEN DO    /* Italiano */
  103.     txt_title_zone    = "Zona spirale"
  104.     txt_gad_x0        = "Centro _X:"
  105.     txt_gad_y0        = "Centro _Y:"
  106.     txt_gad_radiusx   = "_Raggio X:"
  107.     txt_gad_radiusy   = "Raggi_o Y:"
  108.     txt_title_set     = "Parametri spirale"
  109.     txt_gad_font      = "_Font:"
  110.     txt_gad_text      = "_Testo:"
  111.     txt_string_text   = "Questo è un testo a spirale."
  112.     txt_gad_sheight   = "Altezza i_niziale:"
  113.     txt_gad_eheight   = "Altezza fina_le:"
  114.     txt_gad_fall      = "_Caduta %:"
  115.     txt_gad_sangle    = "Ang_olo iniziale:"
  116.     txt_gad_aalias    = "Antialia_s:"
  117.     txt_gad_aalias0   = "Nessuno"
  118.     txt_gad_aalias1   = "Basso"
  119.     txt_gad_aalias2   = "Medio"
  120.     txt_gad_aalias3   = "Alto"
  121.     txt_err_nofonts   = "Non vi sono font vettoriali"
  122.     txt_err_procss    = "Errore elaborazione immagine: "
  123.     txt_err_nomem     = "Memoria insufficiente"
  124.     txt_err_small     = "L'area definita è troppo piccola"
  125.     txt_err_oldclient = "Questa procedura richiede_una versione più recente_di Personal Paint"
  126. END
  127. ELSE DO            /* English */
  128.     txt_title_zone    = "Whirlpool Area"
  129.     txt_gad_x0        = "Center _X:"
  130.     txt_gad_y0        = "Center _Y:"
  131.     txt_gad_radiusx   = "_Radius X:"
  132.     txt_gad_radiusy   = "Radiu_s Y:"
  133.     txt_title_set     = "Whirlpool Settings"
  134.     txt_gad_font      = "_Font:"
  135.     txt_gad_text      = "_Text:"
  136.     txt_string_text   = "This is a whirlpool text."
  137.     txt_gad_sheight   = "_Start Height:"
  138.     txt_gad_eheight   = "_End Height:"
  139.     txt_gad_fall      = "Fa_ll %:"
  140.     txt_gad_sangle    = "Start _Angle:"
  141.     txt_gad_aalias    = "A_ntialias:"
  142.     txt_gad_aalias0   = "None"
  143.     txt_gad_aalias1   = "Low"
  144.     txt_gad_aalias2   = "Medium"
  145.     txt_gad_aalias3   = "High"
  146.     txt_err_nofonts   = "Vector fonts not found"
  147.     txt_err_procss    = "Image processing error: "
  148.     txt_err_small     = "The selected area is too small"
  149.     txt_err_nomem     = "Not enough memory"
  150.     txt_err_oldclient = "This script requires a newer_version of Personal Paint"
  151. END
  152.  
  153. Version 'REXX'
  154. IF RESULT < 7 THEN DO
  155.     RequestNotify 'PROMPT "'txt_err_oldclient'"'
  156.     EXIT 10
  157. END
  158.  
  159.  
  160. /* Ellipse Definition */
  161.  
  162. GetCurrentBrush
  163. savebsh = RESULT
  164. SetCurrentBrush 'RECTANGULAR WIDTH 1 HEIGHT 1'
  165.  
  166. prev_xp = x0
  167. prev_yp = y0
  168. drawn = 0
  169.  
  170. DO FOREVER
  171.     GetMousePosition
  172.     PARSE VAR RESULT xp yp .
  173.  
  174.     IF xp ~= prev_xp | yp ~= prev_yp | ~drawn THEN DO
  175.         IF drawn THEN
  176.             Undo
  177.         radiusx = ABS(x0 - xp)
  178.         radiusy = ABS(y0 - yp)
  179.         DrawEllipse x0 y0 radiusx radiusy
  180.  
  181.         prev_xp = xp
  182.         prev_yp = yp
  183.         drawn = 1
  184.     END
  185.     ELSE WaitForEvent
  186.  
  187.     GetMouseButton
  188.     IF RESULT ~= button THEN
  189.         LEAVE
  190. END
  191.  
  192. Undo
  193. SetCurrentBrush savebsh
  194.  
  195.  
  196. FreeBrush
  197. IF RC ~= 0 THEN
  198.     EXIT RC
  199.  
  200. /* Setting Requester */
  201.  
  202. def_font_path = "FONTS:"
  203. max_text_size = 8000
  204.  
  205. font_path = LoadSet('PP_VectorPath', def_font_path, 1, 0)
  206.  
  207.  
  208. ftot = 0
  209. vftfname = 'ENV:PP_VectorFonts'
  210. IF ~OPEN(fexists, vftfname) THEN DO
  211.     ADDRESS COMMAND 'List >'vftfname' 'font_path' PAT=#?.otag NOHEAD LFORMAT="%s"'
  212.     ADDRESS COMMAND 'Sort 'vftfname vftfname'.s'
  213.     IF RC = 0 THEN DO
  214.         ADDRESS COMMAND 'Delete >NIL: 'vftfname
  215.         ADDRESS COMMAND 'Copy >NIL: 'vftfname'.s' vftfname
  216.         ADDRESS COMMAND 'Delete >NIL: 'vftfname'.s'
  217.     END
  218. END
  219. ELSE CALL CLOSE(fexists)
  220.  
  221. IF OPEN('listfile', vftfname) THEN DO
  222.     DO FOREVER
  223.         fline = READLN('listfile')
  224.         IF EOF('listfile') THEN BREAK
  225.         ftot = ftot + 1
  226.         fontname.ftot = LEFT(fline, LENGTH(fline) - 5)
  227.     END
  228.     CALL CLOSE('listfile')
  229. END
  230.  
  231. IF ftot = 0 THEN DO
  232.     RequestNotify 'PROMPT "'txt_err_nofonts'"'
  233.     EXIT 10
  234. END
  235.  
  236.  
  237. IF radiusx < 2 & radiusy < 2 THEN DO        /* simple click */
  238.     lastpar = LoadSet('LastParams', '0 0 100 100')
  239.     PARSE VAR lastpar x0 y0 radiusx radiusy
  240.     Request '"'txt_title_zone'" ' ||,
  241.             '"INTSTR = ""'txt_gad_x0'"", 0, 32000, 'x0' ' ||,
  242.              'INTSTR = ""'txt_gad_y0'"", 0, 32000, 'y0' ' ||,
  243.              'INTSTR = ""'txt_gad_radiusx'"", 1, 32000, 'radiusx' ' ||,
  244.              'INTSTR = ""'txt_gad_radiusy'"", 1, 32000, 'radiusy' "'
  245.     IF RC ~= 0 THEN
  246.         EXIT RC
  247.     x0 = RESULT.1
  248.     y0 = RESULT.2
  249.     radiusx = RESULT.3
  250.     radiusy = RESULT.4
  251. END
  252.  
  253.  
  254. fntnum  = LoadSet('Font', 0)
  255. text    = LoadSet('Text', txt_string_text)
  256. height  = LoadSet('StartHeight', 50)
  257. eheight = LoadSet('EndHeight', 20)
  258. fallpc  = LoadSet('Fall', 100)
  259. angle   = LoadSet('StartAngle', 0)
  260. aalias  = LoadSet('Antialias', 0)
  261.  
  262. req = '"LIST = ""'txt_gad_font'"", 'ftot', 'fntnum', 20, 5'
  263. DO f = 1 TO ftot
  264.     req = req || ', ""' || fontname.f || '""'
  265. END
  266.  
  267. req = req ||,
  268.      ' VSPACE = 2 ' ||,
  269.       'STRING = ""'txt_gad_text'"", 'max_text_size', ""'text'"" ' ||,
  270.       'INTSTR = ""'txt_gad_sheight'"", 1, 32000, 'height' ' ||,
  271.       'INTSTR = ""'txt_gad_eheight'"", 1, 32000, 'eheight' ' ||,
  272.       'INTSTR = ""'txt_gad_fall'"", 0, 32000, 'fallpc' ' ||,
  273.       'VSPACE = 2 ' ||,
  274.       'SLIDE = ""'txt_gad_sangle'"", -360, 360, 'angle' ' ||,
  275.       'VSPACE = 2 ' ||,
  276.         'CYCLE = ""'txt_gad_aalias'"", 4, 'aalias', ""'txt_gad_aalias0'"", ""'txt_gad_aalias1'"", ""'txt_gad_aalias2'"", ""'txt_gad_aalias3'"" ' ||,
  277.       'VSPACE = 2 "'
  278.  
  279. LockGUI
  280. Request 'RESIZE COMPACT "'txt_title_set'" 'req
  281. IF RC = 0 THEN DO
  282.     fntnum  = RESULT.1 + 1
  283.     text    = RESULT.2
  284.     height  = RESULT.3
  285.     eheight = RESULT.4
  286.     fallpc  = RESULT.5
  287.     angle   = RESULT.6
  288.     aalias  = RESULT.7
  289.  
  290.     CALL SaveSet('Font', fntnum - 1)        /* setting persistence */
  291.     CALL SaveSet('Text', text)
  292.     CALL SaveSet('StartHeight', height)
  293.     CALL SaveSet('EndHeight', eheight)
  294.     CALL SaveSet('Fall', fallpc)
  295.     CALL SaveSet('StartAngle', angle)
  296.     CALL SaveSet('Antialias', aalias)
  297.     CALL SaveSet('LastParams', x0 y0 radiusx radiusy)
  298.  
  299.     IF radiusx < 1 | radiusy < 1 THEN DO
  300.         RequestNotify 'PROMPT "'txt_err_small'"'
  301.         len = 0
  302.     END
  303.  
  304.     angle = angle * 1000
  305.     IF angle < 0 THEN
  306.         angle = 360000 + angle
  307.     IF angle >= 360000 THEN
  308.         angle = angle - 360000
  309.  
  310.     GetPen 'FOREGROUND'
  311.     pen = RESULT
  312.     savepen = pen
  313.     SIGNAL ON Break_C
  314.  
  315.     tchar. = ''
  316.     tpen. = pen
  317.     len = ParseText(text, pen)
  318.  
  319.     GetImageAttributes 'DPIX'
  320.     dpix = RESULT
  321.     GetImageAttributes 'DPIY'
  322.     imgratio = dpix / RESULT
  323.  
  324.     rxdelta = (height * imgratio / 360000) * fallpc / 100
  325.     rydelta = (height / 360000) * fallpc / 100
  326.     hdelta = (height - eheight) / len
  327.  
  328.     DO c = 1 TO len
  329.         rx = TRUNC(radiusx + 0.5)
  330.         ry = TRUNC(radiusy + 0.5)
  331.         GetEllipsePoint x0 y0 rx ry angle 'IMAGERATIO'
  332.         PARSE VAR RESULT px py cangle .
  333.  
  334.         nextc = c + 1
  335.         VectorCharacter 'CHARACTER "'tchar.c || tchar.nextc'" FONTPATH "'font_path'" FONTNAME "'fontname.fntnum'" HEIGHT 'TRUNC(height + 0.5)' ANGLE 'cangle' ANTIALIAS 'aalias
  336.         IF RC = 0 THEN DO
  337.             PARSE VAR RESULT addx addy handlex handley . . nextwidth
  338.             GetBrushAttributes 'HANDLEX'
  339.             hx = RESULT
  340.             GetBrushAttributes 'HANDLEY'
  341.             hy = RESULT
  342.             SetBrushAttributes 'HANDLEX 'handlex' HANDLEY 'handley
  343.             SetPaintMode 'COLOR'
  344.             SetPen 'FOREGROUND' tpen.c
  345.  
  346.             IF aalias > 0 THEN DO
  347.                 Process 'IMAGE BRUSHMODE X0 'px' Y0 'py' FILTER "Brush Alpha Channel (Single)" NOFS'
  348.                 IF RC ~= 0 THEN DO
  349.                     IF RC ~= 5 THEN
  350.                         RequestNotify 'PROMPT "'txt_err_procss || RC'"'
  351.                     LEAVE
  352.                 END
  353.             END
  354.             ELSE PutBrush px py
  355.  
  356.             edgex = px - handlex + hx + addx
  357.             edgey = py - handley + hy + addy
  358.             dist = nextwidth % 2
  359.  
  360.             GetEllipseAngle x0 y0 rx ry edgex edgey dist angle 'IMAGERATIO INCREASING'
  361.             IF RC ~= 0 THEN
  362.                 LEAVE
  363.             new_angle = RESULT
  364.             IF new_angle >= angle THEN
  365.                 angle_step = new_angle - angle
  366.             ELSE
  367.                 angle_step = 360000 - angle + new_angle
  368.             angle = new_angle
  369.  
  370.             radiusx = radiusx - (rxdelta * angle_step)
  371.             radiusy = radiusy - (rydelta * angle_step)
  372.             IF radiusx < 1 | radiusy < 1 THEN
  373.                 LEAVE
  374.         END
  375.         ELSE DO
  376.             RequestNotify 'PROMPT "'txt_err_nomem'"'
  377.             LEAVE
  378.         END
  379.         height = height - hdelta
  380.     END
  381.     SetPen 'FOREGROUND' savepen
  382.     FreeBrush 'FORCE'
  383. END
  384. UnlockGUI
  385.  
  386. EXIT 0
  387.  
  388.  
  389.  
  390.  
  391. ParseText: PROCEDURE EXPOSE tchar. tpen.
  392.  
  393.     tstring = ARG(1)
  394.     tpn = ARG(2)
  395.     tlen = LENGTH(tstring)
  396.     tpos = 1
  397.     tnum = 0
  398.  
  399.     DO UNTIL tpos > tlen
  400.         td = SUBSTR(tstring, tpos, 1)
  401.         tnewpen = ''
  402.         IF td = '[' THEN DO    /* [###] */
  403.             tnewpos = tpos + 1
  404.             IF SUBSTR(tstring, tnewpos, 1) = '[' THEN
  405.                 tpos = tpos + 1
  406.             ELSE DO
  407.                 DO FOREVER
  408.                     tc = SUBSTR(tstring, tnewpos, 1)
  409.                     IF tc < '0' | tc > '9' THEN
  410.                         LEAVE
  411.                     tnewpen = tnewpen || tc
  412.                     tnewpos = tnewpos + 1
  413.                 END
  414.             END
  415.         END
  416.         ELSE IF C2D(td) = 27 THEN DO    /* Esc[3###m */
  417.             IF SUBSTR(tstring, tpos+1, 2) == '[3' THEN DO
  418.                 tnewpos = tpos + 3
  419.                 DO FOREVER
  420.                     tc = SUBSTR(tstring, tnewpos, 1)
  421.                     IF tc < '0' | tc > '9' THEN
  422.                         LEAVE
  423.                     tnewpen = tnewpen || tc
  424.                     tnewpos = tnewpos + 1
  425.                 END
  426.             END
  427.         END
  428.         ELSE IF td = '"' THEN
  429.             td = '""'
  430.  
  431.         IF tnewpen == '' THEN DO
  432.             tnum = tnum + 1
  433.             tchar.tnum = td
  434.             tpen.tnum = tpn
  435.             tpos = tpos + 1
  436.         END
  437.         ELSE DO
  438.             tpn = tnewpen
  439.             tpos = tnewpos + 1
  440.         END
  441.     END
  442.  
  443.     RETURN tnum
  444.  
  445.  
  446.  
  447.  
  448. SaveSet: PROCEDURE
  449.  
  450.     sname = ARG(1)
  451.     val = ARG(2)
  452.  
  453.     IF OPEN('settingfile', 'ENV:PP_Whirlpool_'sname, 'W') THEN DO
  454.         CALL WRITECH('settingfile', val)
  455.         CALL CLOSE('settingfile')
  456.     END
  457.  
  458.     RETURN
  459.  
  460.  
  461.  
  462.  
  463. LoadSet: PROCEDURE
  464.  
  465.     sname = ARG(1)
  466.     def_val = ARG(2)
  467.     IF ARG() > 2 THEN
  468.         global_set = ARG(3)
  469.     ELSE
  470.         global_set = 0
  471.     IF ARG() > 3 THEN
  472.         request_quote = ARG(4)
  473.     ELSE
  474.         request_quote = 1
  475.  
  476.     val = def_val
  477.     IF global_set THEN
  478.         set_fname = 'ENV:'sname
  479.     ELSE
  480.         set_fname = 'ENV:PP_Whirlpool_'sname
  481.  
  482.     IF OPEN('settingfile', set_fname, 'R') THEN DO
  483.         val = READCH('settingfile', 65535)
  484.         CALL CLOSE('settingfile')
  485.     END
  486.  
  487.     IF request_quote THEN DO
  488.         /* encode quotes for the Request command ('"' -> '\""') */
  489.         qpos_start = 1
  490.         DO FOREVER
  491.             qpos = INDEX(val, '"', qpos_start)
  492.             IF qpos = 0 THEN BREAK
  493.             val = INSERT('\"', val, qpos-1)
  494.             qpos_start = qpos + 3
  495.         END
  496.     END
  497.  
  498.     RETURN val
  499.  
  500.  
  501.  
  502.  
  503. Break_C:
  504.  
  505.     SetPen 'FOREGROUND' savepen
  506.     FreeBrush 'FORCE'
  507.     UnlockGUI
  508.  
  509.     RETURN
  510.